home *** CD-ROM | disk | FTP | other *** search
/ Programmer Power Tools / Programmer Power Tools.iso / microcrn / issue_48.arc / RLEDCOMP.ARC / RLEDCOMP.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1989-05-19  |  4.0 KB  |  149 lines
  1. unit rledcomp;
  2.  
  3. (*
  4.    Michael S. Hunt   April 4, 1989
  5.    released into the public domain
  6.  
  7.    Support text from Micro Cornucopia Magazine Issue #48
  8.  
  9.    Micro Cornucopia
  10.    PO Box 223
  11.    Bend, OR 97709
  12. *)
  13.  
  14. interface
  15.  
  16. procedure RleCompBuff (var src, dest;
  17.                       repeatCode : byte;
  18.                       srcSize : word;
  19.                       var destSize : word);
  20.  
  21. procedure RleDecompBuff (var src, dest;
  22.                         srcSize : word);
  23.  
  24. procedure RleCompFile (var sFil, dFil : file; repeatCode : byte);
  25.  
  26. procedure RleDecompFile (var sFil, dFil: file);
  27.  
  28. implementation
  29.  
  30. type  bytes = array [1..65535] of byte;
  31.  
  32. procedure RleCompBuff (var src, dest;
  33.                       repeatCode : byte;
  34.                       srcSize : word;
  35.                       var destSize : word);
  36. var   sPos, dPos : word;
  37.       k, repeatCount : byte;
  38. begin
  39.   repeatCount := 1;
  40.   sPos := 0;
  41.   dPos := 2;
  42.   bytes(dest)[1] := repeatCode;
  43.   repeat
  44.     sPos := sPos + 1;
  45.     if (sPos < srcSize) AND (bytes(src)[sPos] = bytes(src)[sPos+1])
  46.                         AND (repeatCount < 255) then
  47.       repeatCount := repeatCount + 1
  48.     else
  49.       if repeatCount > 3 then
  50.         begin
  51.           bytes(dest)[dPos] := repeatCode;
  52.           bytes(dest)[dPos+1] := bytes(src)[sPos];
  53.           bytes(dest)[dPos+2] := repeatCount;
  54.           dPos := dPos + 3;
  55.           repeatCount := 1
  56.         end
  57.       else
  58.         begin
  59.           for k := 1 to repeatCount do
  60.             bytes(dest)[dPos+k-1] := bytes(src)[sPos];
  61.           dPos := dPos + repeatCount;
  62.           repeatCount := 1
  63.         end;
  64.   until sPos = srcSize;
  65.   destSize := dPos - 1
  66. end; (* RleCompBuff *)
  67.  
  68. procedure RleDecompBuff (var src, dest;
  69.                         srcSize : word);
  70. var   dPos, sPos : word;
  71.       j : byte;
  72. begin
  73.   sPos := 2;
  74.   dPos :=1;
  75.   while sPos <= srcSize do
  76.     begin
  77.       if bytes(src)[sPos] = bytes(src)[1] then
  78.         begin
  79.           for j := 1 to bytes(src)[sPos+2] do
  80.             bytes(dest)[dPos+j-1] := bytes(src)[sPos+1];
  81.           dPos := dPos + bytes(src)[sPos+2];
  82.           sPos := sPos + 3
  83.         end
  84.       else
  85.         begin
  86.           bytes(dest)[dPos] := bytes(src)[sPos];
  87.           dPos := dPos + 1;
  88.           sPos := sPos + 1
  89.         end
  90.     end
  91. end; (* RleDecompBuff *)
  92.  
  93. procedure RleCompFile (var sFil, dFil : file; repeatCode : byte);
  94. var   bytesRead : word;
  95.       k, repeatCount, curByte, repeatByte, nextByte : byte;
  96. begin
  97.   repeatCount := 1;
  98.   BlockRead (sFil, curByte, 1, bytesRead);
  99.   if bytesRead > 0 then
  100.     BlockWrite (dFil, repeatCode, 1);
  101.     repeat
  102.       BlockRead (sFil, nextByte, 1, bytesRead);
  103.       if (curByte = nextByte) AND (repeatCount < 255)
  104.                               AND (bytesRead = 1) then
  105.         repeatCount := repeatCount + 1
  106.       else
  107.         if repeatCount > 3 then
  108.           begin
  109.             BlockWrite(dFil, repeatCode, 1);
  110.             BlockWrite(dFil, curByte, 1);
  111.             BlockWrite(dFil, repeatCount, 1);
  112.             repeatCount := 1
  113.           end
  114.         else
  115.           begin
  116.             for k := 1 to repeatCount do
  117.               BlockWrite(dFil, curByte, 1);
  118.             repeatCount := 1
  119.           end;
  120.       curByte := nextByte
  121.     until bytesRead = 0
  122. end; (* RleCompFile *)
  123.  
  124. procedure RleDecompFile (var sFil, dFil: file);
  125. var   bytesRead : word;
  126.       repeatByte, repeatcode, repeatCount, curByte, i : byte;
  127. begin
  128.   BlockRead (sFil, repeatCode, 1, bytesRead);
  129.   if bytesRead > 0 then
  130.     begin
  131.       BlockRead (sFil, curByte, 1, bytesRead);
  132.       while bytesread > 0 do
  133.         begin
  134.           if curByte = repeatCode then
  135.             begin
  136.               BlockRead (sFil, repeatByte, 1, bytesRead);
  137.               BlockRead (sFil, repeatCount, 1, bytesRead);
  138.               for i := 1 to repeatCount do
  139.                 BlockWrite(dFil, repeatByte, 1)
  140.             end
  141.           else
  142.             BlockWrite(dFil, curByte, 1);
  143.           BlockRead (sFil, curByte, 1, bytesRead);
  144.         end
  145.     end
  146. end; (* RleDecompFile *)
  147.  
  148. begin
  149. end.